home *** CD-ROM | disk | FTP | other *** search
/ SGI Freeware 1999 August / SGI Freeware 1999 August.iso / dist / fw_xemacs.idb / usr / freeware / lib / xemacs-20.4 / lisp / vm / vm-summary.el.z / vm-summary.el
Encoding:
Text File  |  1998-05-21  |  35.5 KB  |  1,035 lines
  1. ;;; Summary gathering and formatting routines for VM
  2. ;;; Copyright (C) 1989-1995 Kyle E. Jones
  3. ;;;
  4. ;;; This program is free software; you can redistribute it and/or modify
  5. ;;; it under the terms of the GNU General Public License as published by
  6. ;;; the Free Software Foundation; either version 1, or (at your option)
  7. ;;; any later version.
  8. ;;;
  9. ;;; This program is distributed in the hope that it will be useful,
  10. ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11. ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  12. ;;; GNU General Public License for more details.
  13. ;;;
  14. ;;; You should have received a copy of the GNU General Public License
  15. ;;; along with this program; if not, write to the Free Software
  16. ;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  17.  
  18. (provide 'vm-summary)
  19.  
  20. (defun vm-summary-mode-internal ()
  21.   (setq mode-name "VM Summary"
  22.     major-mode 'vm-summary-mode
  23.     mode-line-format vm-mode-line-format
  24.     ;; must come after the setting of major-mode
  25.     mode-popup-menu (and vm-use-menus vm-popup-menu-on-mouse-3
  26.                  (vm-menu-support-possible-p)
  27.                  (vm-menu-mode-menu))
  28.     buffer-read-only t
  29.     vm-summary-pointer nil
  30.     vm-summary-=> (if (stringp vm-summary-arrow) vm-summary-arrow "")
  31.     vm-summary-no-=> (make-string (length vm-summary-=>) ? )
  32.     truncate-lines t)
  33.   ;; horizontal scrollbar off by default
  34.   ;; user can turn it on in summary hook if desired.
  35.   (and vm-xemacs-p (featurep 'scrollbar)
  36.        (set-specifier scrollbar-height (cons (current-buffer) 0)))
  37.   (use-local-map vm-summary-mode-map)
  38.   (and (vm-menu-support-possible-p)
  39.        (vm-menu-install-menus))
  40. ;; using the 'mouse-face property gives faster highlighting than this.
  41. ;;  (and vm-mouse-track-summary
  42. ;;       (vm-mouse-support-possible-p)
  43. ;;       (vm-mouse-xemacs-mouse-p)
  44. ;;       (add-hook 'mode-motion-hook 'mode-motion-highlight-line))
  45.   (if (and vm-mutable-frames (or vm-frame-per-folder vm-frame-per-summary))
  46.       (vm-set-hooks-for-frame-deletion))
  47.   (run-hooks 'vm-summary-mode-hook)
  48.   ;; Lucid Emacs apparently used this name
  49.   (run-hooks 'vm-summary-mode-hooks))
  50.  
  51. (fset 'vm-summary-mode 'vm-mode)
  52. (put 'vm-summary-mode 'mode-class 'special)
  53.  
  54. (defun vm-summarize (&optional display raise)
  55.   "Summarize the contents of the folder in a summary buffer. 
  56. The format is as described by the variable vm-summary-format.  Generally
  57. one line per message is most pleasing to the eye but this is not
  58. mandatory."
  59.   (interactive "p\np")
  60.   (vm-select-folder-buffer)
  61.   (vm-check-for-killed-summary)
  62.   (if (null vm-summary-buffer)
  63.       (let ((b (current-buffer))
  64.         (read-only vm-folder-read-only))
  65.     (setq vm-summary-buffer
  66.           (get-buffer-create (format "%s Summary" (buffer-name))))
  67.     (save-excursion
  68.       (set-buffer vm-summary-buffer)
  69.       (abbrev-mode 0)
  70.       (auto-fill-mode 0)
  71.       (if (fboundp 'buffer-disable-undo)
  72.           (buffer-disable-undo (current-buffer))
  73.         ;; obfuscation to make the v19 compiler not whine
  74.         ;; about obsolete functions.
  75.         (let ((x 'buffer-flush-undo))
  76.           (funcall x (current-buffer))))
  77.       (setq vm-mail-buffer b
  78.         vm-folder-read-only read-only)
  79.       (vm-summary-mode-internal))
  80.     (vm-set-summary-redo-start-point t)))
  81.   (if display
  82.       (save-excursion
  83.     (vm-goto-new-summary-frame-maybe)
  84.     (vm-display vm-summary-buffer t
  85.             '(vm-summarize
  86.               vm-summarize-other-frame)
  87.             (list this-command) (not raise))
  88.     ;; need to do this after any frame creation because the
  89.     ;; toolbar sets frame-specific height and width specifiers.
  90.     (set-buffer vm-summary-buffer)
  91.     (and (vm-toolbar-support-possible-p) vm-use-toolbar
  92.          (vm-toolbar-install-toolbar)))
  93.     (vm-display nil nil '(vm-summarize vm-summarize-other-frame)
  94.         (list this-command)))
  95.   (vm-update-summary-and-mode-line))
  96.  
  97. (defun vm-summarize-other-frame (&optional display)
  98.   "Like vm-summarize, but run in a newly created frame."
  99.   (interactive "p")
  100.   (if (vm-multiple-frames-possible-p)
  101.       (vm-goto-new-frame 'summary))
  102.   (vm-summarize display)
  103.   (if (vm-multiple-frames-possible-p)
  104.       (vm-set-hooks-for-frame-deletion)))
  105.  
  106. (defun vm-do-summary (&optional start-point)
  107.   (let ((m-list (or start-point vm-message-list))
  108.     mp m
  109.     (n 0)
  110.     ;; Just for laughs, make the update interval vary.
  111.     (modulus (+ (% (vm-abs (random)) 11) 10))
  112.     (do-mouse-track
  113.         (and vm-mouse-track-summary
  114.          (vm-mouse-support-possible-p)))
  115.     summary)
  116.     (setq mp m-list)
  117.     (save-excursion
  118.       (set-buffer vm-summary-buffer)
  119.       (let ((buffer-read-only nil)
  120.         (modified (buffer-modified-p)))
  121.     (unwind-protect
  122.         (progn
  123.           (if start-point
  124.           (if (vm-su-start-of (car mp))
  125.               (progn
  126.             (goto-char (vm-su-start-of (car mp)))
  127.             (delete-region (point) (point-max)))
  128.             (goto-char (point-max)))
  129.         (erase-buffer)
  130.         (setq vm-summary-pointer nil))
  131.           ;; avoid doing long runs down the marker chain while
  132.           ;; building the summary.  use integers to store positions
  133.           ;; and then convert them to markers after all the
  134.           ;; insertions are done.
  135.           (while mp
  136.         (setq summary (vm-su-summary (car mp)))
  137.         (vm-set-su-start-of (car mp) (point))
  138.         (insert vm-summary-no-=>)
  139.         (vm-tokenized-summary-insert (car mp) (vm-su-summary (car mp)))
  140.         (vm-set-su-end-of (car mp) (point))
  141.         (setq mp (cdr mp) n (1+ n))
  142.         (if (zerop (% n modulus))
  143.             (message "Generating summary... %d" n)))
  144.           ;; now convert the ints to markers.
  145.           (if (>= n modulus)
  146.           (message "Generating summary markers... "))
  147.           (setq mp m-list)
  148.           (while mp
  149.         (setq m (car mp))
  150.         (and do-mouse-track
  151.              (vm-set-su-summary-mouse-track-overlay-of
  152.               m
  153.               (vm-mouse-set-mouse-track-highlight
  154.                (vm-su-start-of m)
  155.                (vm-su-end-of m))))
  156.         (vm-set-su-start-of m (vm-marker (vm-su-start-of m)))
  157.         (vm-set-su-end-of m (vm-marker (vm-su-end-of m)))
  158.         (setq mp (cdr mp))))
  159.       (set-buffer-modified-p modified))
  160.     (run-hooks 'vm-summary-redo-hook)))
  161.     (if (>= n modulus)
  162.     (message "Generating summary... done"))))
  163.  
  164. (defun vm-do-needed-summary-rebuild ()
  165.   (if (and vm-summary-redo-start-point vm-summary-buffer)
  166.       (progn
  167.     (vm-copy-local-variables vm-summary-buffer 'vm-summary-show-threads)
  168.     (vm-do-summary (and (consp vm-summary-redo-start-point)
  169.                 vm-summary-redo-start-point))
  170.     (setq vm-summary-redo-start-point nil)
  171.     (and vm-message-pointer
  172.          (vm-set-summary-pointer (car vm-message-pointer)))
  173.     (setq vm-need-summary-pointer-update nil))
  174.     (and vm-need-summary-pointer-update
  175.      vm-summary-buffer
  176.      vm-message-pointer
  177.      (progn
  178.        (vm-set-summary-pointer (car vm-message-pointer))
  179.        (setq vm-need-summary-pointer-update nil)))))
  180.  
  181. (defun vm-update-message-summary (m)
  182.   (if (and (vm-su-start-of m)
  183.        (marker-buffer (vm-su-start-of m)))
  184.       (let ((modified (buffer-modified-p))
  185.         (do-mouse-track
  186.          (and vm-mouse-track-summary
  187.           (vm-mouse-support-possible-p)))
  188.         summary)
  189.     (save-excursion
  190.       (setq summary (vm-su-summary m))
  191.       (set-buffer (marker-buffer (vm-su-start-of m)))
  192.       (let ((buffer-read-only nil)
  193.         (selected nil)
  194.         (modified (buffer-modified-p)))
  195.         (unwind-protect
  196.         (save-excursion
  197.           (goto-char (vm-su-start-of m))
  198.           (setq selected (not (looking-at vm-summary-no-=>)))
  199.           ;; We do a little dance to update the text in
  200.           ;; order to make the markers in the text do
  201.           ;; what we want.
  202.           ;;
  203.           ;; 1. We need to avoid having the su-start-of
  204.           ;;    and su-end-of markers clumping together at
  205.           ;;    the start position.
  206.           ;;
  207.           ;; 2. We want the window point marker (w->pointm
  208.           ;;    in the Emacs display code) to move to the
  209.           ;;    start of the summary entry if it is
  210.           ;;    anywhere within the su-start-of to
  211.           ;;    su-end-of region.
  212.           ;;
  213.           ;; We achieve (2) by deleting before inserting.
  214.           ;; Reversing the order of insertion/deletion
  215.           ;; pushes the point marker into the next
  216.           ;; summary entry. We achieve (1) by inserting a
  217.           ;; placeholder character at the end of the
  218.           ;; summary entry before deleting the region.
  219.           (goto-char (vm-su-end-of m))
  220.           (insert-before-markers "z")
  221.           (goto-char (vm-su-start-of m))
  222.           (delete-region (point) (1- (vm-su-end-of m)))
  223.           (if (not selected)
  224.               (insert vm-summary-no-=>)
  225.             (insert vm-summary-=>))
  226.           (vm-tokenized-summary-insert m (vm-su-summary m))
  227.           (delete-char 1)
  228.           (run-hooks 'vm-summary-update-hook)
  229.           (and do-mouse-track
  230.                (vm-mouse-set-mouse-track-highlight
  231.             (vm-su-start-of m)
  232.             (vm-su-end-of m)
  233.             (vm-su-summary-mouse-track-overlay-of m)))
  234.           (if (and selected vm-summary-highlight-face)
  235.               (vm-summary-highlight-region (vm-su-start-of m) (point)
  236.                            vm-summary-highlight-face)))
  237.           (set-buffer-modified-p modified)))))))
  238.  
  239. (defun vm-set-summary-pointer (m)
  240.   (if vm-summary-buffer
  241.       (let ((w (vm-get-visible-buffer-window vm-summary-buffer))
  242.         (do-mouse-track
  243.            (and vm-mouse-track-summary
  244.             (vm-mouse-support-possible-p)))
  245.         (old-window nil))
  246.     (vm-save-buffer-excursion
  247.       (unwind-protect
  248.           (progn
  249.         (set-buffer vm-summary-buffer)
  250.         (if w
  251.             (progn
  252.               (setq old-window (selected-window))
  253.               (select-window w)))
  254.         (let ((buffer-read-only nil))
  255.           (if (and vm-summary-pointer
  256.                (vm-su-start-of vm-summary-pointer))
  257.               (progn
  258.             (goto-char (vm-su-start-of vm-summary-pointer))
  259.             (insert vm-summary-no-=>)
  260.             (delete-char (length vm-summary-=>))
  261.             (and do-mouse-track
  262.                  (vm-mouse-set-mouse-track-highlight
  263.                   (vm-su-start-of vm-summary-pointer)
  264.                   (vm-su-end-of vm-summary-pointer)
  265.                   (vm-su-summary-mouse-track-overlay-of
  266.                    vm-summary-pointer)))))
  267.           (setq vm-summary-pointer m)
  268.           (goto-char (vm-su-start-of m))
  269.           (let ((modified (buffer-modified-p)))
  270.             (unwind-protect
  271.             (progn
  272.               (insert vm-summary-=>)
  273.               (delete-char (length vm-summary-=>))
  274.               (and do-mouse-track
  275.                    (vm-mouse-set-mouse-track-highlight
  276.                 (vm-su-start-of m) (vm-su-end-of m)
  277.                 (vm-su-summary-mouse-track-overlay-of m))))
  278.               (set-buffer-modified-p modified)))
  279.           (forward-char (- (length vm-summary-=>)))
  280.           (if vm-summary-highlight-face
  281.               (vm-summary-highlight-region
  282.                (vm-su-start-of m) (vm-su-end-of m)
  283.                vm-summary-highlight-face))
  284.           (and w vm-auto-center-summary (vm-auto-center-summary))
  285.           (run-hooks 'vm-summary-pointer-update-hook)))
  286.         (and old-window (select-window old-window)))))))
  287.  
  288. (defun vm-summary-highlight-region (start end face)
  289.   (cond (vm-fsfemacs-p
  290.      (if (and vm-summary-overlay (overlay-buffer vm-summary-overlay))
  291.          (move-overlay vm-summary-overlay start end)
  292.        (setq vm-summary-overlay (make-overlay start end))
  293.        (overlay-put vm-summary-overlay 'evaporate nil)
  294.        (overlay-put vm-summary-overlay 'face face)))
  295.     (vm-xemacs-p
  296.      (if (and vm-summary-overlay (extent-end-position vm-summary-overlay))
  297.          (set-extent-endpoints vm-summary-overlay start end)
  298.        (setq vm-summary-overlay (make-extent start end))
  299.        ;; the reason this isn't needed under FSF Emacs is
  300.        ;; that insert-before-markers also inserts before
  301.        ;; overlays!  so a summary update of an entry just
  302.        ;; before this overlay in the summary buffer won't
  303.        ;; leak into the overlay, but it _will_ leak into an
  304.        ;; XEmacs extent.
  305.        (set-extent-property vm-summary-overlay 'start-open t)
  306.        (set-extent-property vm-summary-overlay 'detachable nil)
  307.        (set-extent-property vm-summary-overlay 'face face)))))
  308.  
  309. (defun vm-auto-center-summary ()
  310.   (if vm-auto-center-summary
  311.       (if (or (eq vm-auto-center-summary t) (not (one-window-p t)))
  312.       (recenter '(4)))))
  313.  
  314. (defun vm-sprintf (format-variable message &optional tokenize)
  315.   ;; compile the format into an eval'able s-expression
  316.   ;; if it hasn't been compiled already.
  317.   (if (not (eq (get format-variable 'vm-compiled-format)
  318.            (symbol-value format-variable)))
  319.       (vm-compile-format format-variable tokenize))
  320.   ;; The local variable name `vm-su-message' is mandatory here for
  321.   ;; the format s-expression to work.
  322.   (let ((vm-su-message message))
  323.     (eval (get format-variable 'vm-format-sexp))))
  324.  
  325. (defun vm-tokenized-summary-insert (message tokens)
  326.   (if (stringp tokens)
  327.       (insert tokens)
  328.     (let (token)
  329.       (while tokens
  330.     (setq token (car tokens))
  331.     (cond ((stringp token)
  332.            (if vm-display-using-mime
  333.            (insert (vm-decode-mime-encoded-words-in-string token))
  334.          (insert token)))
  335.           ((eq token 'number)
  336.            (insert (vm-padded-number-of message)))
  337.           ((eq token 'mark)
  338.            (insert (vm-su-mark message)))
  339.           ((eq token 'thread-indent)
  340.            (if (and vm-summary-show-threads
  341.             (natnump vm-summary-thread-indent-level))
  342.            (insert-char ?\ (* vm-summary-thread-indent-level
  343.                       (vm-th-thread-indentation message))))))
  344.     (setq tokens (cdr tokens))))))
  345.  
  346. (defun vm-compile-format (format-variable &optional tokenize)
  347.   (let ((format (symbol-value format-variable))
  348.     (case-fold-search nil)
  349.     (done nil)
  350.     (list nil)
  351.     (sexp nil)
  352.     (sexp-fmt nil)
  353.     (last-match-end 0)
  354.     token conv-spec)
  355.     (store-match-data nil)
  356.     (while (not done)
  357.       (setq token nil)
  358.       (while
  359.       (and (not token)
  360.            (string-match
  361.         "%\\(-\\)?\\([0-9]+\\)?\\(\\.\\(-?[0-9]+\\)\\)?\\([aAcdfFhHiIlLmMnstTwyz*%]\\|U[A-Za-z]\\)"
  362.         format (match-end 0)))
  363.     (setq conv-spec (aref format (match-beginning 5)))
  364.     (if (memq conv-spec '(?a ?A ?c ?d ?f ?F ?h ?H ?i ?L ?I ?l ?M
  365.                  ?m ?n ?s ?t ?T ?U ?w ?y ?z ?* ))
  366.         (progn
  367.           (cond ((= conv-spec ?a)
  368.              (setq sexp (cons (list 'vm-su-attribute-indicators
  369.                         'vm-su-message) sexp)))
  370.             ((= conv-spec ?A)
  371.              (setq sexp (cons (list 'vm-su-attribute-indicators-long
  372.                         'vm-su-message) sexp)))
  373.             ((= conv-spec ?c)
  374.              (setq sexp (cons (list 'vm-su-byte-count
  375.                         'vm-su-message) sexp)))
  376.             ((= conv-spec ?d)
  377.              (setq sexp (cons (list 'vm-su-monthday
  378.                         'vm-su-message) sexp)))
  379.             ((= conv-spec ?f)
  380.              (setq sexp (cons (list 'vm-su-interesting-from
  381.                         'vm-su-message) sexp)))
  382.             ((= conv-spec ?F)
  383.              (setq sexp (cons (list 'vm-su-interesting-full-name
  384.                         'vm-su-message) sexp)))
  385.             ((= conv-spec ?h)
  386.              (setq sexp (cons (list 'vm-su-hour
  387.                         'vm-su-message) sexp)))
  388.             ((= conv-spec ?H)
  389.              (setq sexp (cons (list 'vm-su-hour-short
  390.                         'vm-su-message) sexp)))
  391.             ((= conv-spec ?i)
  392.              (setq sexp (cons (list 'vm-su-message-id
  393.                         'vm-su-message) sexp)))
  394.             ((= conv-spec ?I)
  395.              (if tokenize
  396.              (setq token ''thread-indent)
  397.                (setq sexp (cons (list 'vm-su-thread-indent
  398.                           'vm-su-message) sexp))))
  399.             ((= conv-spec ?l)
  400.              (setq sexp (cons (list 'vm-su-line-count
  401.                         'vm-su-message) sexp)))
  402.             ((= conv-spec ?L)
  403.              (setq sexp (cons (list 'vm-su-labels
  404.                         'vm-su-message) sexp)))
  405.             ((= conv-spec ?m)
  406.              (setq sexp (cons (list 'vm-su-month
  407.                         'vm-su-message) sexp)))
  408.             ((= conv-spec ?M)
  409.              (setq sexp (cons (list 'vm-su-month-number
  410.                         'vm-su-message) sexp)))
  411.             ((= conv-spec ?n)
  412.              (if tokenize
  413.              (setq token ''number)
  414.                (setq sexp (cons (list 'vm-padded-number-of
  415.                           'vm-su-message) sexp))))
  416.             ((= conv-spec ?s)
  417.              (setq sexp (cons (list 'vm-su-subject
  418.                         'vm-su-message) sexp)))
  419.             ((= conv-spec ?T)
  420.              (setq sexp (cons (list 'vm-su-to-names
  421.                         'vm-su-message) sexp)))
  422.             ((= conv-spec ?t)
  423.              (setq sexp (cons (list 'vm-su-to
  424.                         'vm-su-message) sexp)))
  425.             ((= conv-spec ?U)
  426.              (setq sexp
  427.                (cons (list 'vm-run-user-summary-function
  428.                        (list 'quote
  429.                          (intern
  430.                           (concat
  431.                            "vm-summary-function-"
  432.                            (substring
  433.                         format
  434.                         (1+ (match-beginning 5))
  435.                         (+ 2 (match-beginning 5))))))
  436.                        'vm-su-message) sexp)))
  437.             ((= conv-spec ?w)
  438.              (setq sexp (cons (list 'vm-su-weekday
  439.                         'vm-su-message) sexp)))
  440.             ((= conv-spec ?y)
  441.              (setq sexp (cons (list 'vm-su-year
  442.                         'vm-su-message) sexp)))
  443.             ((= conv-spec ?z)
  444.              (setq sexp (cons (list 'vm-su-zone
  445.                         'vm-su-message) sexp)))
  446.             ((= conv-spec ?*)
  447.              (if tokenize
  448.              (setq token ''mark)
  449.                (setq sexp (cons (list 'vm-su-mark
  450.                           'vm-su-message) sexp)))))
  451.           (cond ((and (not token) vm-display-using-mime)
  452.              (setcar sexp
  453.                  (list 'vm-decode-mime-encoded-words-in-string
  454.                    (car sexp)))))
  455.           (cond ((and (not token) (match-beginning 1) (match-beginning 2))
  456.              (setcar sexp
  457.                  (list
  458.                   (if (eq (aref format (match-beginning 2)) ?0)
  459.                   'vm-numeric-left-justify-string
  460.                 'vm-left-justify-string)
  461.                   (car sexp)
  462.                   (string-to-int
  463.                    (substring format
  464.                       (match-beginning 2)
  465.                       (match-end 2))))))
  466.             ((and (not token) (match-beginning 2))
  467.              (setcar sexp
  468.                  (list
  469.                   (if (eq (aref format (match-beginning 2)) ?0)
  470.                   'vm-numeric-right-justify-string
  471.                 'vm-right-justify-string)
  472.                   (car sexp)
  473.                   (string-to-int
  474.                    (substring format
  475.                       (match-beginning 2)
  476.                       (match-end 2)))))))
  477.           (cond ((and (not token) (match-beginning 3))
  478.              (setcar sexp
  479.                  (list 'vm-truncate-string (car sexp)
  480.                    (string-to-int
  481.                     (substring format
  482.                            (match-beginning 4)
  483.                            (match-end 4)))))))
  484.           (cond ((and (not token) vm-display-using-mime)
  485.              (setcar sexp
  486.                  (list 'vm-reencode-mime-encoded-words-in-string
  487.                    (car sexp)))))
  488.           (setq sexp-fmt
  489.             (cons (if token "" "%s")
  490.               (cons (substring format
  491.                        last-match-end
  492.                        (match-beginning 0))
  493.                 sexp-fmt))))
  494.       (setq sexp-fmt
  495.         (cons "%%"
  496.               (cons (substring format
  497.                        (or last-match-end 0)
  498.                        (match-beginning 0))
  499.                 sexp-fmt))))
  500.       (setq last-match-end (match-end 0)))
  501.       (if (not token)
  502.       (setq sexp-fmt
  503.         (cons (substring format last-match-end (length format))
  504.               sexp-fmt)
  505.         done t))
  506.       (setq sexp-fmt (apply 'concat (nreverse sexp-fmt)))
  507.       (if sexp
  508.       (setq sexp (cons 'format (cons sexp-fmt (nreverse sexp))))
  509.     (setq sexp sexp-fmt))
  510.       (if tokenize
  511.       (setq list (nconc list (if (equal sexp "") nil (list sexp))
  512.                 (and token (list token)))
  513.         sexp nil
  514.         sexp-fmt nil)))
  515.     (put format-variable 'vm-compiled-format format)
  516.     (put format-variable 'vm-format-sexp (if list (cons 'list list) sexp))))
  517.  
  518. (defun vm-get-header-contents (message header-name-regexp &optional clump-sep)
  519.   (let ((contents nil)
  520.     regexp)
  521.     (setq regexp (concat "^\\(" header-name-regexp "\\)")
  522.       message (vm-real-message-of message))
  523.     (save-excursion
  524.       (set-buffer (vm-buffer-of (vm-real-message-of message)))
  525.       (save-restriction
  526.     (widen)
  527.     (goto-char (vm-headers-of message))
  528.     (let ((case-fold-search t))
  529.       (while (and (or (null contents) clump-sep)
  530.               (re-search-forward regexp (vm-text-of message) t)
  531.               (save-excursion (goto-char (match-beginning 0))
  532.                       (vm-match-header)))
  533.         (if contents
  534.         (setq contents
  535.               (concat contents clump-sep (vm-matched-header-contents)))
  536.           (setq contents (vm-matched-header-contents))))))
  537.       contents )))
  538.  
  539. (defun vm-left-justify-string (string width)
  540.   (if (>= (length string) width)
  541.       string
  542.     (concat string (make-string (- width (length string)) ?\ ))))
  543.  
  544. (defun vm-right-justify-string (string width)
  545.   (if (>= (length string) width)
  546.       string
  547.     (concat (make-string (- width (length string)) ?\ ) string)))
  548.  
  549. (defun vm-numeric-left-justify-string (string width)
  550.   (if (>= (length string) width)
  551.       string
  552.     (concat string (make-string (- width (length string)) ?0))))
  553.  
  554. (defun vm-numeric-right-justify-string (string width)
  555.   (if (>= (length string) width)
  556.       string
  557.     (concat (make-string (- width (length string)) ?0) string)))
  558.  
  559. (defun vm-truncate-string (string width)
  560.   (cond
  561. ;; doesn't work because the width of wide chars such as the Kanji
  562. ;; glyphs as not even multiples of the default face's font width.
  563. ;;    ((fboundp 'char-width)
  564. ;;     (let ((i 0)
  565. ;;           (lim (length string))
  566. ;;           (total 0))
  567. ;;       (while (and (< i lim) (<= total width))
  568. ;;         (setq total (+ total (char-width (aref string i)))
  569. ;;           i (1+ i)))
  570. ;;       (if (<= total width)
  571. ;;           string
  572. ;;         (substring string 0 (1- i)))))
  573.     ((<= (length string) width)
  574.      string)
  575.     ((< width 0)
  576.      (substring string width))
  577.     (t
  578.      (substring string 0 width))))
  579.  
  580. (defun vm-su-attribute-indicators (m)
  581.   (concat
  582.    (cond ((vm-deleted-flag m) "D")
  583.      ((vm-new-flag m) "N")
  584.      ((vm-unread-flag m) "U")
  585.      (t " "))
  586.    (cond ((vm-filed-flag m) "F")
  587.      ((vm-written-flag m) "W")
  588.      (t " "))
  589.    (cond ((vm-replied-flag m) "R")
  590.      ((vm-forwarded-flag m) "Z")
  591.      ((vm-redistributed-flag m) "B")
  592.      (t " "))
  593.    (cond ((vm-edited-flag m) "E")
  594.      (t " "))))
  595.  
  596. (defun vm-su-attribute-indicators-long (m)
  597.   (concat
  598.    (cond ((vm-deleted-flag m) "D")
  599.      ((vm-new-flag m) "N")
  600.      ((vm-unread-flag m) "U")
  601.      (t " "))
  602.    (if (vm-replied-flag m) "r" " ")
  603.    (if (vm-forwarded-flag m) "z" " ")
  604.    (if (vm-redistributed-flag m) "b" " ")
  605.    (if (vm-filed-flag m) "f" " ")
  606.    (if (vm-written-flag m) "w" " ")
  607.    (if (vm-edited-flag m) "e" " ")))
  608.  
  609. (defun vm-su-byte-count (m)
  610.   (or (vm-byte-count-of m)
  611.       (vm-set-byte-count-of
  612.        m
  613.        (int-to-string
  614.     (- (vm-text-end-of (vm-real-message-of m))
  615.        (vm-text-of (vm-real-message-of m)))))))
  616.  
  617. (defun vm-su-weekday (m)
  618.   (or (vm-weekday-of m)
  619.       (progn (vm-su-do-date m) (vm-weekday-of m))))
  620.  
  621. (defun vm-su-monthday (m)
  622.   (or (vm-monthday-of m)
  623.       (progn (vm-su-do-date m) (vm-monthday-of m))))
  624.  
  625. (defun vm-su-month (m)
  626.   (or (vm-month-of m)
  627.       (progn (vm-su-do-date m) (vm-month-of m))))
  628.  
  629. (defun vm-su-month-number (m)
  630.   (or (vm-month-number-of m)
  631.       (progn (vm-su-do-date m) (vm-month-number-of m))))
  632.  
  633. (defun vm-su-year (m)
  634.   (or (vm-year-of m)
  635.       (progn (vm-su-do-date m) (vm-year-of m))))
  636.  
  637. (defun vm-su-hour-short (m)
  638.   (let ((string (vm-su-hour m)))
  639.     (if (> (length string) 5)
  640.     (substring string 0 5)
  641.       string)))
  642.  
  643. (defun vm-su-hour (m)
  644.   (or (vm-hour-of m)
  645.       (progn (vm-su-do-date m) (vm-hour-of m))))
  646.  
  647. (defun vm-su-zone (m)
  648.   (or (vm-zone-of m)
  649.       (progn (vm-su-do-date m) (vm-zone-of m))))
  650.  
  651. (defun vm-su-mark (m) (if (vm-mark-of m) "*" " "))
  652.  
  653. ;; Some yogurt-headed delivery agents don't provide a Date: header.
  654. (defun vm-grok-From_-date (message)
  655.   ;; This works only on the From_ types, obviously
  656.   (if (not (memq (vm-message-type-of message)
  657.          '(From_ From_-with-Content-Length)))
  658.       nil
  659.     (save-excursion
  660.       (set-buffer (vm-buffer-of (vm-real-message-of message)))
  661.       (save-excursion
  662.     (save-restriction
  663.       (widen)
  664.       (goto-char (vm-start-of message))
  665.       (let ((case-fold-search nil))
  666.         (if (or (looking-at
  667.              ;; special case this so that the "remote from blah"
  668.              ;; isn't included.
  669.              "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\) remote from .*")
  670.             (looking-at "From [^ \t\n]*[ \t]+\\([^ \t\n].*\\)"))
  671.         (vm-buffer-substring-no-properties
  672.          (match-beginning 1)
  673.          (match-end 1)))))))))
  674.  
  675. (defun vm-parse-date (date)
  676.   (let ((weekday "")
  677.     (monthday "")
  678.     (month "")
  679.     (year "")
  680.     (hour "")
  681.     (timezone "")
  682.     (start nil)
  683.     string
  684.     (case-fold-search t))
  685.     (if (string-match "sun\\|mon\\|tue\\|wed\\|thu\\|fri\\|sat" date)
  686.     (setq weekday (substring date (match-beginning 0) (match-end 0))))
  687.     (if (string-match "jan\\|feb\\|mar\\|apr\\|may\\|jun\\|jul\\|aug\\|sep\\|oct\\|nov\\|dec" date)
  688.     (setq month (substring date (match-beginning 0) (match-end 0))))
  689.     (if (string-match "[0-9]?[0-9]:[0-9][0-9]\\(:[0-9][0-9]\\)?" date)
  690.     (setq hour (substring date (match-beginning 0) (match-end 0))))
  691.     (if (or (string-match "[^a-z][+---][0-9][0-9][0-9][0-9]" date)
  692.         (string-match "e[ds]t\\|c[ds]t\\|p[ds]t\\|m[ds]t" date)
  693.         (string-match "ast\\|nst\\|met\\|eet\\|jst\\|bst\\|ut" date)
  694.         (string-match "gmt\\([+---][0-9]+\\)?" date))
  695.     (setq timezone (substring date (match-beginning 0) (match-end 0))))
  696.     (while (string-match "\\(\\`\\|[^:+---0-9]\\|[a-z]-\\)[0-9]+\\(\\'\\|[^:]\\)"
  697.              date start)
  698.       (setq string (substring date (match-end 1) (match-beginning 2))
  699.         start (match-end 0))
  700.       (cond ((string-match "\\`[4-9]." string)
  701.          ;; Assume that any two digits less than 40 are a date and not
  702.          ;; a year.  The world will surely end soon.
  703.          (setq year (concat "19" string)))
  704.         ((< (length string) 3)
  705.          (setq monthday string))
  706.         (t (setq year string))))
  707.     
  708.     (aset vm-parse-date-workspace 0 weekday)
  709.     (aset vm-parse-date-workspace 1 monthday)
  710.     (aset vm-parse-date-workspace 2 month)
  711.     (aset vm-parse-date-workspace 3 year)
  712.     (aset vm-parse-date-workspace 4 hour)
  713.     (aset vm-parse-date-workspace 5 timezone)
  714.     vm-parse-date-workspace))
  715.  
  716. (defun vm-su-do-date (m)
  717.   (let ((case-fold-search t)
  718.     vector date)
  719.     (setq date (or (vm-get-header-contents m "Date:") (vm-grok-From_-date m)))
  720.     (cond
  721.      ((null date)
  722.       (vm-set-weekday-of m "")
  723.       (vm-set-monthday-of m "")
  724.       (vm-set-month-of m "")
  725.       (vm-set-month-number-of m "")
  726.       (vm-set-year-of m "")
  727.       (vm-set-hour-of m "")
  728.       (vm-set-zone-of m ""))
  729.      ((string-match
  730. ;; The date format recognized here is the one specified in RFC 822.
  731. ;; Some slop is allowed e.g. dashes between the monthday, month and year
  732. ;; because such malformed headers have been observed.
  733. "\\(\\([a-z][a-z][a-z]\\),\\)?[ \t\n]*\\([0-9][0-9]?\\)[ \t\n---]*\\([a-z][a-z][a-z]\\)[ \t\n---]*\\([0-9]*[0-9][0-9]\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)"
  734.        date)
  735.       (if (match-beginning 2)
  736.       (vm-set-weekday-of m (substring date (match-beginning 2)
  737.                       (match-end 2)))
  738.     (vm-set-weekday-of m ""))
  739.       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
  740.       (vm-su-do-month m (substring date (match-beginning 4) (match-end 4)))
  741.       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
  742.       (if (= 2 (length (vm-year-of m)))
  743.       (vm-set-year-of m (concat "19" (vm-year-of m))))
  744.       (vm-set-hour-of m (substring date (match-beginning 6) (match-end 6)))
  745.       (vm-set-zone-of m (substring date (match-beginning 7) (match-end 7))))
  746.      ((string-match
  747. ;; UNIX ctime(3) format, with slop allowed in the whitespace, and we allow for
  748. ;; the possibility of a timezone at the end.
  749. "\\([a-z][a-z][a-z]\\)[ \t\n]*\\([a-z][a-z][a-z]\\)[ \t\n]*\\([0-9][0-9]?\\)[ \t\n]*\\([0-9:]+\\)[ \t\n]*\\([0-9][0-9][0-9][0-9]\\)[ \t\n]*\\([a-z][a-z]?[a-z]?\\|[---+][0-9][0-9][0-9][0-9]\\)?"
  750.        date)
  751.       (vm-set-weekday-of m (substring date (match-beginning 1) (match-end 1)))
  752.       (vm-su-do-month m (substring date (match-beginning 2) (match-end 2)))
  753.       (vm-set-monthday-of m (substring date (match-beginning 3) (match-end 3)))
  754.       (vm-set-hour-of m (substring date (match-beginning 4) (match-end 4)))
  755.       (vm-set-year-of m (substring date (match-beginning 5) (match-end 5)))
  756.       (if (match-beginning 6)
  757.       (vm-set-zone-of m (substring date (match-beginning 6)
  758.                        (match-end 6)))
  759.     (vm-set-zone-of m "")))
  760.      (t
  761.       (setq vector (vm-parse-date date))
  762.       (vm-set-weekday-of m (elt vector 0))
  763.       (vm-set-monthday-of m (elt vector 1))
  764.       (vm-su-do-month m (elt vector 2))
  765.       (vm-set-year-of m (elt vector 3))
  766.       (vm-set-hour-of m (elt vector 4))
  767.       (vm-set-zone-of m (elt vector 5)))))
  768.  
  769.   ;; Normalize all hour and date specifications to avoid jagged margins.
  770.   ;; If the hour is " 3:..." or "3:...", turn it into "03:...".
  771.   ;; If the date is "03", turn it into " 3".
  772.   (cond ((null (vm-hour-of m)) nil)
  773.     ((string-match "\\`[0-9]:" (vm-hour-of m))
  774.      (vm-set-hour-of m (concat "0" (vm-hour-of m)))))
  775.   (cond ((null (vm-monthday-of m)) nil)
  776.     ((string-match "\\`0[0-9]\\'" (vm-monthday-of m))
  777.      (vm-set-monthday-of m (substring (vm-monthday-of m) 1 2))))
  778.   )
  779.  
  780. (defun vm-su-do-month (m month-abbrev)
  781.   (let ((val (assoc (downcase month-abbrev) vm-month-alist)))
  782.     (if val
  783.     (progn (vm-set-month-of m (nth 1 val))
  784.            (vm-set-month-number-of m (nth 2 val)))
  785.       (vm-set-month-of m "")
  786.       (vm-set-month-number-of m ""))))
  787.  
  788. (defun vm-run-user-summary-function (function message)
  789.   (let ((message (vm-real-message-of message)))
  790.     (save-excursion
  791.       (set-buffer (vm-buffer-of message))
  792.       (save-restriction
  793.     (widen)
  794.     (save-excursion
  795.       (narrow-to-region (vm-headers-of message) (vm-text-end-of message))
  796.       (funcall function message))))))
  797.  
  798. (defun vm-su-full-name (m)
  799.   (or (vm-full-name-of m)
  800.       (progn (vm-su-do-author m) (vm-full-name-of m))))
  801.  
  802. (defun vm-su-interesting-full-name (m)
  803.   (if vm-summary-uninteresting-senders
  804.       (let ((case-fold-search nil))
  805.     (if (string-match vm-summary-uninteresting-senders (vm-su-from m))
  806.         (concat vm-summary-uninteresting-senders-arrow (vm-su-to-names m))
  807.       (vm-su-full-name m)))
  808.     (vm-su-full-name m)))
  809.  
  810. (defun vm-su-from (m)
  811.   (or (vm-from-of m)
  812.       (progn (vm-su-do-author m) (vm-from-of m))))
  813.  
  814. (defun vm-su-interesting-from (m)
  815.   (if vm-summary-uninteresting-senders
  816.       (let ((case-fold-search nil))
  817.     (if (string-match vm-summary-uninteresting-senders (vm-su-from m))
  818.         (concat vm-summary-uninteresting-senders-arrow (vm-su-to m))
  819.       (vm-su-from m)))
  820.     (vm-su-from m)))
  821.  
  822. ;; Some yogurt-headed delivery agents don't even provide a From: header.
  823. (defun vm-grok-From_-author (message)
  824.   ;; This works only on the From_ types, obviously
  825.   (if (not (memq (vm-message-type-of message)
  826.          '(From_ From_-with-Content-Length)))
  827.       nil
  828.     (save-excursion
  829.       (set-buffer (vm-buffer-of message))
  830.       (save-excursion
  831.     (save-restriction
  832.       (widen)
  833.       (goto-char (vm-start-of message))
  834.       (let ((case-fold-search nil))
  835.         (if (looking-at "From \\([^ \t\n]+\\)")
  836.         (vm-buffer-substring-no-properties
  837.          (match-beginning 1)
  838.          (match-end 1)))))))))
  839.  
  840. (defun vm-su-do-author (m)
  841.   (let ((full-name (vm-get-header-contents m "Full-Name:"))
  842.     (from (or (vm-get-header-contents m "From:" ", ")
  843.           (vm-grok-From_-author m)))
  844.     pair i)
  845.     (if (and full-name (string-match "^[ \t]*$" full-name))
  846.     (setq full-name nil))
  847.     (if (null from)
  848.     (progn
  849.       (setq from "???")
  850.       (if (null full-name)
  851.           (setq full-name "???")))
  852.       (setq pair (funcall vm-chop-full-name-function from)
  853.         from (or (nth 1 pair) from)
  854.         full-name (or full-name (nth 0 pair) from)))
  855.     (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name)
  856.      (setq full-name
  857.            (substring full-name (match-beginning 1) (match-end 1))))
  858.     (while (setq i (string-match "\n" full-name i))
  859.       (aset full-name i ?\ ))
  860.     (vm-set-full-name-of m full-name)
  861.     (vm-set-from-of m from)))
  862.  
  863. (defun vm-default-chop-full-name (address)
  864.   (let ((from address)
  865.     (full-name nil))
  866.     (cond ((string-match
  867. "\\`[ \t\n]*\\([^< \t\n]+\\([ \t\n]+[^< \t\n]+\\)*\\)?[ \t\n]*<\\([^>]+\\)>[ \t\n]*\\'"
  868.              address)
  869.        (if (match-beginning 1)
  870.            (setq full-name
  871.              (substring address (match-beginning 1) (match-end 1))))
  872.        (setq from
  873.          (substring address (match-beginning 3) (match-end 3))))
  874.       ((string-match
  875. "\\`[ \t\n]*\\(\\(\"[^\"]+\"\\|[^\"( \t\n]\\)+\\)[ \t\n]*(\\([^ \t\n]+\\([ \t\n]+[^ \t\n]+\\)*\\)?)[ \t\n]*\\'"
  876.              address)
  877.        (if (match-beginning 3)
  878.            (setq full-name
  879.              (substring address (match-beginning 3) (match-end 3))))
  880.        (setq from
  881.          (substring address (match-beginning 1) (match-end 1)))))
  882.     (list full-name from)))
  883.  
  884. ;; test for existence and functionality of mail-extract-address-components
  885. ;; there are versions out there that don't work right, so we run
  886. ;; some test data through it to see if we can trust it.
  887. (defun vm-choose-chop-full-name-function (address)
  888.   (let ((test-data '(("kyle@uunet.uu.net" .
  889.               (nil "kyle@uunet.uu.net"))
  890.              ("c++std=lib@inet.research.att.com" .
  891.               (nil "c++std=lib@inet.research.att.com"))
  892.              ("\"Piet.Rypens\" <rypens@reks.uia.ac.be>" .
  893.               ("Piet Rypens" "rypens@reks.uia.ac.be"))
  894.              ("makke@wins.uia.ac.be (Marc.Gemis)" .
  895.               ("Marc Gemis" "makke@wins.uia.ac.be"))
  896.              ("" . (nil nil))))
  897.     (failed nil)
  898.     result)
  899.     (while test-data
  900.       (setq result (condition-case nil
  901.                (mail-extract-address-components (car (car test-data)))
  902.              (error nil)))
  903.       (if (not (equal result (cdr (car test-data))))
  904.       ;; failed test, use default
  905.       (setq failed t
  906.         test-data nil)
  907.     (setq test-data (cdr test-data))))
  908.     (if failed
  909.     ;; it failed, use default
  910.     (setq vm-chop-full-name-function 'vm-default-chop-full-name)
  911.       ;; it passed the tests
  912.       (setq vm-chop-full-name-function 'mail-extract-address-components))
  913.     (funcall vm-chop-full-name-function address)))
  914.  
  915. (defun vm-su-do-recipients (m)
  916.   (let ((mail-use-rfc822 t) i names addresses to cc all list full-name)
  917.     (setq to (or (vm-get-header-contents m "To:" ", ")
  918.          (vm-get-header-contents m "Apparently-To:" ", ")
  919.          ;; desperation....
  920.          (user-login-name))
  921.       cc (vm-get-header-contents m "Cc:" ", ")
  922.       all to
  923.       all (if all (concat all ", " cc) cc)
  924.       addresses (rfc822-addresses all))
  925.     (setq list (vm-parse-addresses all))
  926.     (while list
  927.       ;; Just like vm-su-do-author:
  928.       (setq full-name (or (nth 0 (funcall vm-chop-full-name-function
  929.                       (car list)))
  930.               (car list)))
  931.       ;; If double quoted are around the full name, fish the name out.
  932.       (if (string-match "\\`\"\\([^\"]+\\)\"\\'" full-name)
  933.       (setq full-name
  934.         (substring full-name (match-beginning 1) (match-end 1))))
  935.       (while (setq i (string-match "\n" full-name i))
  936.     (aset full-name i ?\ ))
  937.       (setq names (cons full-name names))
  938.       (setq list (cdr list)))
  939.     (setq names (nreverse names)) ; added by jwz for fixed vm-parse-addresses
  940.     (vm-set-to-of m (mapconcat 'identity addresses ", "))
  941.     (vm-set-to-names-of m (mapconcat 'identity names ", "))))
  942.  
  943. (defun vm-su-to (m)
  944.   (or (vm-to-of m) (progn (vm-su-do-recipients m) (vm-to-of m))))
  945.  
  946. (defun vm-su-to-names (m)
  947.   (or (vm-to-names-of m) (progn (vm-su-do-recipients m) (vm-to-names-of m))))
  948.                   
  949. (defun vm-su-message-id (m)
  950.   (or (vm-message-id-of m)
  951.       (vm-set-message-id-of
  952.        m
  953.        (or (let ((id (vm-get-header-contents m "Message-Id:")))
  954.          (and id (car (vm-parse id "[^<]*\\(<[^>]+>\\)"))))
  955.        ;; try running md5 on the message body to produce an ID
  956.        ;; better than nothing.
  957.        (save-excursion
  958.          (set-buffer (vm-buffer-of (vm-real-message-of m)))
  959.          (save-restriction
  960.            (widen)
  961.            (condition-case nil
  962.            (concat "<fake-VM-id."
  963.                (vm-pop-md5-string
  964.                 (buffer-substring
  965.                  (vm-text-of (vm-real-message-of m))
  966.                  (vm-text-end-of (vm-real-message-of m))))
  967.                "@talos.iv>")
  968.          (error nil))))
  969.        (concat "<" (int-to-string (vm-abs (random))) "@toto.iv>")))))
  970.  
  971. (defun vm-su-line-count (m)
  972.   (or (vm-line-count-of m)
  973.       (vm-set-line-count-of
  974.        m
  975.        (save-excursion
  976.      (set-buffer (vm-buffer-of (vm-real-message-of m)))
  977.      (save-restriction
  978.        (widen)
  979.        (int-to-string
  980.         (count-lines (vm-text-of (vm-real-message-of m))
  981.              (vm-text-end-of (vm-real-message-of m)))))))))
  982.  
  983. (defun vm-su-subject (m)
  984.   (or (vm-subject-of m)
  985.       (vm-set-subject-of
  986.        m
  987.        (let ((subject (or (vm-get-header-contents m "Subject:" " ") ""))
  988.          (i nil))
  989.      (while (setq i (string-match "\n" subject i))
  990.        (aset subject i ?\ ))
  991.      subject ))))
  992.  
  993. (defun vm-su-summary (m)
  994.   (if (and (vm-virtual-message-p m) (not (vm-virtual-messages-of m)))
  995.       (or (vm-virtual-summary-of m)
  996.       (save-excursion
  997.         (vm-select-folder-buffer)
  998.         (vm-set-virtual-summary-of m (vm-sprintf 'vm-summary-format m t))
  999.         (vm-virtual-summary-of m)))
  1000.     (or (vm-summary-of m)
  1001.     (save-excursion
  1002.       (vm-select-folder-buffer)
  1003.       (vm-set-summary-of m (vm-sprintf 'vm-summary-format m t))
  1004.       (vm-summary-of m)))))
  1005.  
  1006. (defun vm-fix-my-summary!!! ()
  1007.   (interactive)
  1008.   (vm-select-folder-buffer)
  1009.   (vm-check-for-killed-summary)
  1010.   (vm-error-if-folder-empty)
  1011.   (message "Fixing your summary...")
  1012.   (let ((mp vm-message-list))
  1013.     (while mp
  1014.       (vm-set-summary-of (car mp) nil)
  1015.       (vm-mark-for-summary-update (car mp))
  1016.       (setq mp (cdr mp)))
  1017.     (vm-stuff-folder-attributes nil)
  1018.     (set-buffer-modified-p t)
  1019.     (vm-update-summary-and-mode-line))
  1020.   (message "Fixing your summary... done"))
  1021.  
  1022. (defun vm-su-thread-indent (m)
  1023.   (if (natnump vm-summary-thread-indent-level)
  1024.       (make-string (* (vm-th-thread-indentation m)
  1025.               vm-summary-thread-indent-level)
  1026.            ?\ )
  1027.     "" ))
  1028.  
  1029. (defun vm-su-labels (m)
  1030.   (or (vm-label-string-of m)
  1031.       (vm-set-label-string-of
  1032.        m
  1033.        (mapconcat 'identity (vm-labels-of m) ","))
  1034.       (vm-label-string-of m)))
  1035.